home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / Examples / trace-step-gf-patch.lisp < prev    next >
Encoding:
Text File  |  1993-02-01  |  3.2 KB  |  81 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;; trace-step-gf-patch.lisp
  4. ;;copyright © 1992, 1993, Apple Computer, Inc.
  5.  
  6. ; trace :step a generic function traces :step all his methods
  7. ; untrace a gf untraces the methods if so traced
  8.  
  9. (in-package :ccl)
  10.  
  11. (let ((*warn-if-redefine* nil)
  12.       (*warn-if-redefine-kernel* nil))
  13.  
  14.  
  15. (defun %trace (sym &key before after step define-if-not)  
  16.   (let (def newdef trace-thing)
  17.     (multiple-value-setq (def trace-thing) 
  18.       (%trace-function-spec-p sym define-if-not))
  19.     (if def
  20.       (let ()
  21.         (when (%traced-p trace-thing)
  22.           (%untrace-1 trace-thing)
  23.           (setq def (%trace-fboundp trace-thing)))
  24.         (when step   ; just check if has interpreted def
  25.           (if (typep def 'standard-generic-function)
  26.             (let ((methods (%gf-methods def)))
  27.               (dolist (m methods) ; stick :step-gf in advice-when slot
  28.                 (%trace m :step t)
  29.                 (let ((e (function-encapsulation m)))
  30.                   (when e (setf (encapsulation-advice-when e) :step-gf))))
  31.               (if  (or before after)
  32.                 (setq step nil)                
  33.                 (return-from %trace)))
  34.             (uncompile-for-stepping trace-thing nil t)))
  35.         (let ((newsym (gensym "TRACE"))
  36.               (method-p (typep trace-thing 'method)))
  37.           (when (and (null before)(null after)(null step))
  38.             (setq before #'trace-before)
  39.             (setq after #'trace-after))
  40.           (case before 
  41.             (:print (setq before #'trace-before)))
  42.           (case after
  43.             (:print (setq after #'trace-after)))
  44.           (setq newdef (trace-global-def 
  45.                         sym newsym before after step method-p))
  46.           (when method-p
  47.             (copy-method-function-bits def newdef))
  48.           (without-interrupts
  49.            (multiple-value-bind (ignore gf.dcode) (encapsulate trace-thing def 'trace sym newsym)
  50.              (declare (ignore ignore))
  51.              (cond (gf.dcode 
  52.                     (setf (%gf-dcode def)
  53.                           (%cons-combined-method def (cons newdef gf.dcode) #'%%call-gf-encapsulation)))
  54.                    ((symbolp trace-thing) (%fhave trace-thing newdef))
  55.                    ((typep trace-thing 'method)
  56.                     (setf (%method-function trace-thing) newdef)
  57.                     (remove-obsoleted-combined-methods trace-thing)
  58.                     newdef))))))
  59.       (report-bad-arg sym '(satisfies %trace-function-spec-p)))))
  60.  
  61.  
  62. (defun %untrace (sym)
  63.   (when (and (consp sym)(consp (car sym)))
  64.     (setq sym (car sym)))
  65.   (multiple-value-bind (def trace-thing) (%trace-function-spec-p sym)
  66.     (let (val)
  67.       (when (typep def 'standard-generic-function)
  68.         (let ((methods (%gf-methods def)))
  69.           (dolist (m methods)
  70.             (let ((e (function-encapsulation m)))
  71.               (when (and e (eq (encapsulation-advice-when e) :step-gf))
  72.                 (remove-encapsulation e)
  73.                 (push m  val))))))
  74.       ; gf could have first been traced :step, and then just plain traced
  75.       (when (%traced-p trace-thing)
  76.         (%untrace-1 trace-thing)
  77.         (push trace-thing val))
  78.       (if (null (cdr val))(car val) val))))
  79. )
  80.  
  81.